(*
 *    _  _   ____                         _  
 *  _| || |_/ ___|  ___ _ __  _ __   ___ | | 
 * |_  ..  _\___ \ / _ \ '_ \| '_ \ / _ \| | 
 * |_      _|___) |  __/ |_) | |_) | (_) |_| 
 *   |_||_| |____/ \___| .__/| .__/ \___/(_) 
 *                     |_|   |_|             
 *
 * Personal Social Web.
 *
 * Copyright (C) The #Seppo contributors. All rights reserved.
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program.  If not, see <http://www.gnu.org/licenses/>.
 *)

(** https://www.rfc-editor.org/rfc/rfc9651.html#name-abnf

    sf-list       = list-member *( OWS "," OWS list-member )

    list-member   = sf-item / inner-list

    inner-list    = "(" *SP [ sf-item *( 1*SP sf-item ) *SP ] ")"
                parameters

    parameters    = *( ";" *SP parameter )
    parameter     = param-key [ "=" param-value ]
    param-key     = key
    key           = ( lcalpha / "*" )
                *( lcalpha / DIGIT / "_" / "-" / "." / "*" )
    lcalpha       = %x61-7A ; a-z
    param-value   = bare-item

    sf-dictionary = dict-member *( OWS "," OWS dict-member )
    dict-member   = member-key ( parameters / ( "=" member-value ))
    member-key    = key
    member-value  = sf-item / inner-list

    sf-item   = bare-item parameters
    bare-item = sf-integer / sf-decimal / sf-string / sf-token
            / sf-binary / sf-boolean / sf-date / sf-displaystring

    sf-integer       = ["-"] 1*15DIGIT
    sf-decimal       = ["-"] 1*12DIGIT "." 1*3DIGIT
    sf-string        = DQUOTE *( unescaped / "%" / bs-escaped ) DQUOTE
    sf-token         = ( ALPHA / "*" ) *( tchar / ":" / "/" )
    sf-binary        = ":" base64 ":"
    sf-boolean       = "?" ( "0" / "1" )
    sf-date          = "@" sf-integer
    sf-displaystring = "%" DQUOTE *( unescaped / "\\" / pct-encoded )
                   DQUOTE

    base64       = *( ALPHA / DIGIT / "+" / "/" ) *"="

    unescaped    = %x20-21 / %x23-24 / %x26-5B / %x5D-7E
    bs-escaped   = "\\" ( DQUOTE / "\\" )

    pct-encoded  = "%" lc-hexdig lc-hexdig
    lc-hexdig = DIGIT / %x61-66 ; 0-9, a-f
*)

open Angstrom

(** https://www.rfc-editor.org/rfc/rfc5234.html *)
module Rfc5234 = struct
  (** https://www.rfc-editor.org/rfc/rfc5234.html#:~:text=SP%20%20%20%20%20%20%20%20%20%20%20%20%20%3D%20%20%25x20 *)
  let _SP      = satisfy Astring.Char.Ascii.is_white
  let _DIGIT   = Astring.Char.Ascii.is_digit
  let _DQUOTE  = char '"'
end

(** https://www.rfc-editor.org/rfc/rfc9110.html *)
module Rfc9110 = struct
  (** https://www.rfc-editor.org/rfc/rfc9110.html#whitespace *)
  let _OWS     = many Rfc5234._SP
  let _RWS     = many1 Rfc5234._SP
end

let list1 sep i = map2 i (many (sep *> i)) ~f:List.cons
let list sep i = list1 sep i <|> return []
let to_s cs =
  let b = Bytes.make (cs |> List.length) '_' in
  let _ = cs |> List.fold_left (fun i c ->
      Bytes.set b i c;
      succ i) 0 in
  b |> Bytes.to_string

let to_bool          = function
  | '0' -> false
  | '1' -> true
  | _ -> assert false
let _BS              = char '\\'
let _PERCENT         = char '%'
let _COLON           = char ':'
let is_unescaped     = function
  | '\x20'..'\x21'
  | '\x23'..'\x24'
  | '\x26'..'\x58'
  | '\x5D'..'\x7E'
    -> true
  | _ -> false
let lcalpha          = Astring.Char.Ascii.is_lower
let fraction ?(divisor=1000) s =
  let zer = Char.code '0' in
  let _,r = String.fold_left (fun (fa,r as i) c ->
      if fa <= 0
      then i
      else (
        assert (c |> Rfc5234._DIGIT);
        let fa = fa / 10 in
        fa , r + fa * ((c |> Char.code) - zer)
      )) (divisor,0) s in
  r
let p_integer        = take_while1 Rfc5234._DIGIT >>| int_of_string (* or rather use Optint.Int63? *)
let n_integer        = char '-' *> p_integer >>| Int.neg
let sf_integer       = p_integer <|> n_integer
let promille         = take_while1 Rfc5234._DIGIT >>| fraction
let sf_decimal       = map2 sf_integer (char '.' *> promille) ~f:(fun a b -> a,b)
let unescaped        = satisfy is_unescaped
let bs_escaped       = _BS *> Rfc5234._DQUOTE <|> _BS
let sf_string        = Rfc5234._DQUOTE *> many (unescaped <|> _PERCENT <|> bs_escaped) >>| to_s <* Rfc5234._DQUOTE
let tok0 c           = c |> Astring.Char.Ascii.is_letter
                       || c = '*'
(* https://www.rfc-editor.org/rfc/inline-errata/rfc9110.html#:~:text=tchar%20%20%20%20%20%20%20%20%20%20%3D%20 *)
let tchar c          = c |> tok0
                       || c |> Rfc5234._DIGIT
                       || c = '!' || c = '#' || c = '$' || c = '%' || c = '&' || c = '\''
                       || c = '+' || c  = '-' || c = '.' || c = '^' || c = '_' || c = '`' || c = '|' || c = '~'
let tok1 c = c |> tchar
             || c = ':' || c   = '/'
(* https://www.rfc-editor.org/rfc/rfc9651.html#:~:text=sf-token%20%20%20%20%20%20%20%20%20%3D *)
let sf_token         = map2 (satisfy tok0) (many (satisfy tok1)) ~f:(fun a b -> List.cons a b |> to_s)
let bas64 c =
  c |> Astring.Char.Ascii.is_alphanum
  || c = '+'
  || c = '/'
let b64 cs =
  let s =  cs
           |> to_s in
  match (s ^ "==") |> Base64.decode with
  | Ok s -> s |> Bytes.of_string
  | Error (`Msg e) -> failwith e
let base64           = many (satisfy bas64) >>| b64 <* many (char '=')
let sf_binary        = _COLON *> base64 <* _COLON
let sf_date          = char '@' *> sf_integer >>| Ptime.Span.of_int_s
let sf_boolean       = char '?' *> char '0' <|> char '1' >>| to_bool
let lc_hexdig        = satisfy Astring.Char.Ascii.is_hex_digit
let pct_encoded      = _PERCENT *> map2 lc_hexdig lc_hexdig ~f:Hex.to_char
let sf_displaystring = _PERCENT *> Rfc5234._DQUOTE *> many (unescaped <|> _BS <|> pct_encoded) >>| to_s <* Rfc5234._DQUOTE
let bare_item        =
  map sf_integer           ~f:(fun x -> `Sf_Integer x)
  <|> map sf_decimal       ~f:(fun x -> `Sf_Decimal x)
  <|> map sf_string        ~f:(fun x -> `Sf_String x)
  <|> map sf_token         ~f:(fun x -> `Sf_Token x)
  <|> map sf_binary        ~f:(fun x -> `Sf_Binary x)
  <|> map sf_boolean       ~f:(fun x -> `Sf_Boolean x)
  <|> map sf_date          ~f:(fun x -> `Sf_Date x)
  <|> map sf_displaystring ~f:(fun x -> `Sf_Displaystring x)
let key0 c = c |> lcalpha || c = '*'
let key1 c = c |> key0
             || c |> Rfc5234._DIGIT
             || c = '_'
             || c = '-'
             || c = '.'
let key              = map2 (satisfy key0) (many (satisfy key1)) ~f:(fun a b -> List.cons a b |> to_s)
(* https://www.rfc-editor.org/rfc/rfc9651.html#:~:text=param-key%20%20%20%20%20%3D%20key *)
let param_key        = key
let param_value      = bare_item
let parameter        = both param_key (char '=' *> param_value)
let parameters       = many (char ';' *> parameter)
let sf_item          = both bare_item parameters

let inner_list       = both
    (char '(' *> Rfc9110._OWS *> list Rfc9110._RWS sf_item <* Rfc9110._OWS <* char ')' )
    parameters
let list_member      = sf_item <|> (map inner_list ~f:(fun (x,y) -> `Sf_Innerlist x,y))
let sf_list          = map (list1 (Rfc9110._OWS <* char ',' <* Rfc9110._OWS) list_member) ~f:(fun x -> (`Sf_List x),[])
let member_key       = key
let member_value     = list_member
let dict_member      = both (both member_key parameters) (char '=' *> member_value
                                                          <|>
                                                          return (`Sf_Boolean true,[]) )
let sf_dictionary    = map (list1 (Rfc9110._OWS <* char ',' <* Rfc9110._OWS) dict_member) ~f:(fun x -> (`Sf_Dictionary x),[])
(* as the paramter stick outside sd_item the other two at least need the [] *)
let sf               = sf_item <|> sf_list <|> sf_dictionary

let parse_string ?(term = sf) = parse_string ~consume:All term
